CD ROM Paradise Collection 4/CD ROM Paradise Collection 4 1995 Nov.iso/program/swagn_r.zip/OOP.SWG/0054_TV Formatline Unit.pas

Pascal/Delphi Source File | 1995-02-28 | 23KB | 838 lines

{*******************************************************}
{                                                       }
{       Turbo Pascal Version 6.0                        }
{       Optional FormLine Unit                          }
{       for use with Turbo Vision                       }
{                                                       }
{       Copyright (c) 1991  J. John Sprenger            }
{                                                       }
{*******************************************************}

unit FormLine;

{$O+,F+,S+}

interface

uses

  {Turbo Pascal Run-Time Library Units}

  Crt,

  {Turbo Vision Standard Units}

  Objects, Drivers, Views, Dialogs, App,

  {Turbo Vision Accessory Units}

  StdDlg, MsgBox;

const

  { flError, flCharOk and flFormatOK are constants used  }
  { by tFormatLine.CheckPicture.  flError is returned    }
  { when an error is found.  flCharOk when an character  }
  { is found to be appropriate.  And flFormatOk when the }
  { entire input string is found acceptable.             }

  flError    = $0000;
  flCharOK   = $0001;
  flFormatOK = $0002;

  { flCharError is passed to tFormatLine.ReportError     }
  { when a character does not fit the proper form.       }
  { flFormatError is used when the format is not         }
  { satisfied even though input so far is acceptable.    }

  flCharError   = 1;
  flFormatError = 2;

  { CommandSet represents the characters used in Format  }
  { Line Pictures.  These match those used by Paradox.   }

  CommandSet = ['[','{','?','&','@','!','#','{',',',']',
  '}','*'];

type

  { tFormatLine }

  { tFormatLine is the improved tInputLine object which  }
  { accepts Paradox-form Picture strings to ensure that  }
  { data will be entered in an acceptable form.          }

  pFormatLine = ^tFormatLine;
  tFormatLine = object( tInputLine)
    Picture : string;
    constructor Init(var Bounds : tRect; AMaxLen
      : integer; Pic : string);
    function Valid(command : word) : boolean; virtual;
    procedure HandleEvent(var Event : tEvent); virtual;
    function CheckPicture(var s, Pic : string;
      var CPos : integer):word;
    procedure ReportError( kind : word); virtual;
  end;

  { tMoneyFormatLine }

  { tMoneyFormatLine is an input line intended for use   }
  { real number fields associated with money.  Input is  }
  { preceded with a "$" sign and terminated with a "."   }
  { followed by the appropriate fractional value.        }

  pMoneyFormatLine = ^tMoneyFormatLine;
  tMoneyFormatLine = object( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxlen :
      integer);
    procedure SetData(var Rec); virtual;
    procedure GetData(var Rec); virtual;
    function DataSize : word; virtual;
  end;

  { tPhoneFormatLine }

  { tPhoneFormatLine is for phone number fields. Normal  }
  { 10-digit numbers are entered in the following form   }
  { (###) ###-####.  International numbers are entered   }
  { digit after digit with spaces and hyphens where the  }
  { user deems appropriate.                              }

  pPhoneFormatLine = ^tPhoneFormatLine;
  tPhoneFormatLine = object( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxLen :
      integer);
    procedure SetData(var Rec); virtual;
    procedure GetData(var Rec); virtual;
  end;

  { tRealFormatLine }

  { tRealFormatLine is used for real number fields.  It  }
  { can handle both decimal and scientific notations.    }

  pRealFormatLine = ^tRealFormatLine;
  tRealFormatLine = object ( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxLen :
      integer);
    procedure SetData(var Rec); virtual;
    procedure GetData(var Rec); virtual;
    function DataSize : word; virtual;
  end;

  { tIntegerFormatLine }

  { tIntegerFormatLine is used for integer fields.  It   }
  { accepts signed integers.                             }

  pIntegerFormatLine = ^tIntegerFormatLine;
  tIntegerFormatLine = object( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxLen :
      integer);
    procedure SetData(var Rec); virtual;
    procedure GetData(var Rec); virtual;
    function DataSize : word; virtual;
  end;

  { tNameFormatLine }

  { tNameFormatLine accepts words and capitalizes the    }
  { first character of each word.  This would be used    }
  { proper names and addresses.                          }

  pNameFormatLine = ^tNameFormatLine;
  tNameFormatLine = object( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxLen :
      integer);
  end;

  { tZipFormatLine }

  { tZipFormatLine is used for ZIP and Postal Code       }
  { fields.  It handles U.S. and Canadian format codes.  }

  pZipFormatLine = ^tZipFormatLine;
  tZipFormatLine = object( tFormatLine )
    constructor Init(var Bounds : tRect; AMaxLen :
      integer);
    end;

implementation


{ Function Copy represents a bit of syntatic sugar for   }
{ the benefit of the author.  It changes the Copy func.  }
{ so that its parameters represent start and end points  }
{ rather than a start point followed by a quantity.      }

function Copy(s : string; start, stop : integer) : string;
begin
  if stop < start then Copy:=''
  else Copy:=System.Copy(s,start,stop-start+1);
end;



{ Function FindMatch recursively locates the matching   }
{ grouping characters for "{" and "[".                  }

function FindMatch(P : string) : integer;
var
  i:integer;
  match:boolean;
  c:char;
begin
  i:=2;
  match:=false;
  while (i<=length(P)) and not match do
    begin
      if ((p[i]=']') and (p[1]='[')) or ((p[i]='}') and
        (p[1]='{')) then
        match:=true;
      if p[i]='{' then
        i:=i+FindMatch(Copy(p,i,length(p)))
      else if p[i]='[' then
        i:=i+FindMatch(Copy(p,i,length(P)))
      else inc(i);
    end;
  FindMatch:=i-1;
end;



{ tFormatLine.ReportError handles errors found when the  }
{ user keys inappropriate characters or presses ENTER    }
{ when input is incomplete.                              }

procedure tFormatLine.ReportError(kind:word);
var
  w   : word;
  Pic : pstring;
begin
  Pic:=newstr(Picture);
  case kind of
    flCharError :
      begin
        sound(220);
        delay(200);
        nosound;
      end;
    flFormatError :
      begin
        w:=MessageBox('Error in Formatted Input Line'+
          '                      '+
          '%s'+
          '                      '+
          '(Using Paradox Picture Format)',
          @Pic,mfError+mfOkButton);
      end;
    end;
  DisposeStr(Pic);
end;


{ tFormatLine.Valid overrides TView's Valid and reports  }
{ any format errors if the user accepts the input string }
{ before the entire format requirements have been met.   }

function tFormatLine.Valid(command: word):boolean;
var
  result:word;
begin
  result:=CheckPicture(Data^,Picture,CurPos);
  if (result and flFormatOK)=0 then
    begin
      ReportError(flFormatError);
      Select;
      DrawView;
      Valid:=false;
    end
  else Valid:=true;
end;


{ tFormatLine.CheckPicture is the function that inspects }
{ the input string passed as S against the Pic string    }
{ which holds the Paradox-form Picture.  If an error is  }
{ found the position of the error is placed in CPos.     }

function tFormatLine.CheckPicture(var s, Pic : string;
  var CPos : integer) : word;
var
  Resolved  : integer;
  TempIndex : integer;


{ Function CP is the heart of tFormatLine.  It           }
{ determines if the string, s passed to it fits the      }
{ requirements of the picture, Pic.  The number of       }
{ characters successful resolved is returned in the      }
{ parameter resolved. When groups or repetitions are     }
{ encountered CP will call itself recursively.           }

function CP(var s : string; Pic : string; var CPos :
  integer; var Resolved : integer) : word;
const
   CharMatchSet = ['#','?','&','@','!'];
var
  i          : integer;
  index      : integer;
  result     : word;
  commit     : boolean;
  Groupcount : integer;

{ Procedure Succeed resolves defaults and <Space>        }
{ default requests                                       }

  procedure Succeed;
  var
    t     : integer;
    found : boolean;
  begin
  if (s[i]=' ') and (Pic[index]<>' ') and
    (Pic[index]<>',') then
    begin
      t:=index;
      found:=false;
      while (t<=length(pic)) and not found do
        begin
        if not (Pic[t] in (CharMatchSet+
          ['*','[','{',',',']','}'])) then
          begin
            if pic[t]=';' then inc(t);
            s[i]:=Pic[t];
            found:=true;
          end;
          inc(t);
        end;
    end;
  if (i>length(s)) then
    while not (Pic[index] in
      (CharMatchSet+['*','[','{',',',']','}'])) and
      (index<=length(Pic)) and
      not(Pic[index-1] in ['}',',',']']) do
      begin
        if Pic[index]=';' then inc(index);
        s[i]:=Pic[index];
        if i>length(s) then
          begin
            CPos:=i;
            s[0]:=char(i);
          end;
        inc(i);
        inc(index);
      end;
  end;


{ Function AnyLeft returns true if their are no required }
{ characters left in the Picture string.                 }

  function AnyLeft : boolean;
  var TempIndex : integer;
  begin
    TempIndex:=index;
    while ((Pic[TempIndex]='[') or (Pic[TempIndex]='*'))
      and (TempIndex<=Length(Pic)) and
      (Pic[TempIndex]<>',') do
      begin
        if Pic[TempIndex]='[' then
          Tempindex:=Tempindex+FindMatch(Copy(Pic,index,
            Length(Pic)))
        else begin
          if not (Pic[TempIndex+1] in ['0'..'9']) then
            begin
              inc(TempIndex);
              if Pic[TempIndex] in ['{','['] then
                tempIndex:=TempIndex+
                  FindMatch(Copy(pic,index,length(pic)))
              else inc(TempIndex);
            end;
        end;
      end;
    AnyLeft:=(TempIndex<=length(Pic)) and
     (Pic[TempIndex]<>',');
  end;


{ Function CharMatch determines if the current character }
{ matches the corresponding character mask in the        }
{ Picture string. Alters the character if necessary.     }

  function CharMatch : word;
  var result : word;
  begin
    result:=flError;
    case Pic[index] of
      '#': if s[i] in ['0'..'9'] then result:=flCharOk;
      '?': if s[i] in ['A'..'Z','a'..'z'] then
        result:=flCharOk;
      '&': if s[i] in ['A'..'Z','a'..'z'] then
        begin
          result:=flCharOk;
          s[i]:=upcase(s[i]);
        end;
      '@': result:=flCharOk;
      '!':
        begin
         result:=flCharOk;
         s[i]:=upcase(s[i]);
        end;
      end;
    if result<>flError then commit:=true;
    CharMatch:=result;
  end;

{ Function Literal handles characters which are needed   }
{ by the picture by otherwise used as format specifiers. }
{ All such characters are preceded by the ';' in the     }
{ picture string.                                        }

  function Literal : word;
  var result : word;
  begin
    inc(index);
    if s[i]=Pic[index] then result:=flCharOk
    else result:=flError;
    if result<>flError then commit:=true;
    Literal:=result;
  end;


{ Function Group handles required and optional groups    }
{ in the picture string.  These are designated by the    }
(* "{","}" and "[","]" character pairs.                 *)

  function Group:word;
  var
    result: word;
    TempS: string;
    TempPic: string;
    TempCPos: integer;
    PicEnd: integer;
    TempIndex: integer;
    SwapIndex:integer;
    SwapPic : string;
  begin
    TempPic:=Copy(Pic,index,length(Pic));
    PicEnd:=FindMatch(TempPic);
    TempPic:=Copy(TempPic,2,PicEnd-1);
    TempS:=Copy(s,i,length(s));
    TempCPos:=1;

    result:=CP(TempS,TempPic,TempCPos,TempIndex);

    if result=flCharOK then inc(GroupCount);
    if (result=flFormatOK) and (groupcount>0) then
      dec(GroupCount);
    if result<>flError then result:=flCharOk;

    SwapIndex:=index;
    index:=TempIndex;
    SwapPic:=Pic;
    Pic:=TempPic;
    if not AnyLeft then result:=flCharOk;
    pic:=SwapPic;
    index:=SwapIndex;

    if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;

    CPos:=Cpos+TempCPos-1;
    if Pic[index]='[' then
      begin
      if result<>flError then
         i:=i+TempCPos-1
      else dec(i);
      result:=flCharOK;
      end
    else i:=i+TempCPos-1;
    index:=index+PicEnd-1;
    Group:=result;
  end;


{ Function Repetition handles repeated that may be       }
{ repeated in the input string.  The picture string      }
{ indicates this possiblity with "*" character.          }

  function Repetition:word;
  var
    result:word;
    count:integer;
    TempPic:string;
    TempS:string;
    TempCPos:integer;
    TempIndex:integer;
    SwapIndex:integer;
    SwapPic:string;
    PicEnd:integer;
    commit:boolean;

    procedure MakeCount;
    var nstr:string;
        code:integer;
    begin
      if Pic[index] in ['0'..'9'] then
        begin
          nstr:='';
          repeat
            nstr:=nstr+Pic[index];
            inc(index);
          until not(Pic[index] in ['0'..'9']);
          val(nstr,count,code);
        end
      else count:=512;
    end;

    procedure MakePic;
    begin
    if Pic[index] in ['{','['] then
      begin
        TempPic:=copy(Pic,index,length(Pic));
        PicEnd:=FindMatch(TempPic);
        TempPic:=Copy(TempPic,2,PicEnd-1);
      end
    else
      begin
        if Pic[index]<>';' then
          begin
            TempPic:=''+Pic[index];
            PicEnd:=3;
            if index=1 then pic:='{'+pic[index]+'}'+
              copy(pic,index+1,length(pic))
            else pic:=copy(pic,1,index-1)+
              '{'+pic[index]+'}'+
              copy(pic,index+1,length(pic));
          end
        else
          begin
            TempPic:=Pic[index]+Pic[index+1];
            PicEnd:=4;
            if index=1 then pic:='{'+pic[index]+
              pic[index+1]+'}'+
              copy(pic,index+1,length(pic))
            else pic:=copy(pic,1,index-1)+'{'+pic[index]+
              pic[index+1]+'}'+copy(pic,index+1,
              length(pic));
          end;
        end;
    end;

  begin
    inc(index);
    MakeCount;
    MakePic;
    result:=flCharOk;
    while (count<>0) and (result<>flError) and
      (i<=length(s)) do
      begin
        commit:=false;
        TempS:=Copy(s,i,length(s));
        TempCPos:=1;

        result:=CP(TempS,TempPic,TempCPos,TempIndex);

        if result=flCharOK then inc(GroupCount);
        if (result=flFormatOK) and
           (groupcount > 0)  then dec(GroupCount);
        if result<>flError then result:=flCharOk;

        SwapIndex:=Index;
        Index:=TempIndex;
        SwapPic:=Pic;
        Pic:=TempPic;
        if (not AnyLeft) then result:=flCharOk;
        Pic:=SwapPic;
        index:=SwapIndex;
        if i>1 then s:=copy(s,1,i-1)+TempS else s:=TempS;
        Cpos:=Cpos+TempCpos-1;
        if (count>255) then
           begin
           if result<>flError then
              begin
              i:=i+TempCpos-1;
              if not commit then commit:=true;
              result:=flCharOk;
              end
           else dec(i);
           end
        else i:=i+TempCPos-1;
        inc(i);
        dec(count);
      end;
    dec(i);
    index:=index+PicEnd-1;
    if result=flError then
       if (count>255) and not commit
         then result:=flCharOk;
    repetition:=result;
  end;

  begin{ of function CP}
    i:=1;
    index:=1;
    result:=flCharOk;
    commit:=false;
    Groupcount:=0;
    while (i<=length(s)) and (result<>flError) do
      begin
        if index>length(Pic) then result:=flError else
          begin
            if s[i]=' ' then Succeed;
            if Pic[index] in CharMatchSet then
              result:=CharMatch else
            if Pic[index]=';' then
              result:=Literal else
            if (Pic[index]='{') or (Pic[index]='[') then
              result:=Group else
            if Pic[index]='*' then
              result:=Repetition else
            if Pic[index] in [',','}',']'] then
              result:=flError else
            if Pic[index]=s[i] then
              begin
                result:=flCharOk;
                commit:=true;
              end
            else result:=flError;
            if (result = flError) and not commit then
              begin
                TempIndex:=Index;
                while (TempIndex<=length(Pic)) and
                  ((Pic[TempIndex]<>',') and
                  (Pic[TempIndex-1]<>';'))  do
                  begin
                   if (Pic[TempIndex]='{') or
                     (Pic[TempIndex]=']')
                   then Index:=FindMatch( Copy( Pic,
                     TempIndex,length(Pic)))+TempIndex-1;
                   inc(TempIndex);
                 end;
               if Pic[TempIndex]=',' then
                 begin
                   if Pic[TempIndex-1]<>';' then
                     begin
                       result:=flCharOk;
                       index:=TempIndex;
                       inc(index);
                     end;
                 end;
              end
            else if result<>flError then
              begin
                inc(i);
                inc(index);
                Succeed;
              end;

          end;
      end;
    Resolved:=index;

    if (result=flCharOk) and
      (GroupCount=0) and
      (not AnyLeft or ((Pic[index-1]=',') and
      (Pic[index-2]<>';')))
    then result:=flFormatOk;

    CPos:=i-1;
    CP:=result;
  end;

begin{ of function CheckPicture}
Resolved:=1;
CheckPicture:=CP(s,Pic,CPos,Resolved);
end;

{ tFormatLine.Init simply sets up the inputline and then }
{ sets up the Picture string for use by CheckPicture.    }

constructor tFormatLine.Init(var Bounds: tRect;
  AMaxLen: integer; Pic : string);
begin
  tInputLine.Init(Bounds,AMaxLen);
  Picture:=Pic;
end;

{ tFormatLine.HandleEvent intercepts character key       }
{ presses and handles inserting these characters into    }
{ Data field.  Insertion only occures if a call to       }
{ tFormatLine.CheckPicture is successful else            }
{ tFormatLine.ReportError is called.  All other events   }
{ are passed on to tInputLine.HandleEvent.               }

procedure TFormatLine.HandleEvent(var Event: TEvent);
var TempData   : string;
    TempCurPos : integer;
    I          : integer;
begin
if State and sfSelected <> 0 then
   if Event.What=evKeyDown then
      if Event.CharCode in [' '..#255] then
         begin
         TempData:=Data^;
         if State and sfCursorIns<>0 then
            Delete(TempData,CurPos+1,1)
         else begin
              if SelStart<>SelEnd then
                 begin
                 Delete(TempData,SelStart+1
                   ,SelEnd-SelStart);
                 CurPos:=SelStart;
                 end;
              end;
         if Length(TempData)<MaxLen then
            begin
            inc(CurPos);
            insert(Event.CharCode,TempData,CurPos);
            if CheckPicture(TempData,Picture,CurPos)=flError then
               ReportError(flCharError)
            else Data^:=TempData;
            SelStart:=0;
            SelEnd:=0;
            if FirstPos> CurPos then FirstPos:=CurPos;
            I:=CurPos-Size.X+2;
            if FirstPos<I then FirstPos:=I;
            DrawView;
            ClearEvent(Event);
            end;
         end;
tInputLine.HandleEvent(Event);
end;


constructor tMoneyFormatLine.Init;
begin
tFormatLine.Init(Bounds,AMaxLen,'$#[#][#]*{;,###}.##');
end;

procedure tMoneyFormatLine.GetData;
var Figure : real absolute Rec;
    TempData : string;
    i : integer;
    code : integer;
begin
  TempData:=Data^;
  for i:=length(TempData) downto 1 do
      if TempData[i] in ['$',','] then
        Delete(TempData,i,1);
  val(TempData,Figure,code);
  if code<>0 then ReportError(flFormatError);
end;

procedure tMoneyFormatLine.SetData;
var Figure : real absolute Rec;
    TempData : string;
    i,decimal, count : integer;
begin
  str(Figure:0:2,TempData);
  i:=pos('.',TempData);
  count:=0;
  while (i<>1) do
    begin
    inc(count);
    dec(i);
    if count=3 then
      begin
      insert(',',TempData,i);
      count:=0;
      end;
    end;
  if TempData[1]=',' then delete(TempData,1,1);
  Data^:='$'+TempData;
end;

function tMoneyFormatLine.DataSize : word;
begin
DataSize:=sizeof(real);
end;

constructor tPhoneFormatLine.Init;
begin
tFormatLine.Init(Bounds,AMaxLen,
  '(###) ###-####,#*{#, ,-#}');
end;

procedure tPhoneFormatLine.GetData;
var i : integer;
    Default : string absolute Rec;
begin
  for i:=length(Data^) downto 1 do
    if Data^[i] in [' ','-','(',')'] then Delete(Data^,i,1);
Default:=Data^;
end;

procedure tPhoneFormatLine.SetData;
var i:integer;
    Default : string absolute Rec;
begin
if length(Default)=10 then
  Default:='('+Copy(Default,1,3)+') '+Copy(Default,4,6)+
    '-'+Copy(Default,7,10);
Data^:=Default;
end;

constructor tRealFormatLine.Init;
begin
tFormatLine.Init(Bounds, AMaxLen,
  '[+,-]#*#[[.*#][{E,e}[+,-]#[#][#][#]]]');
end;

procedure tRealFormatLine.GetData;
var Result : real absolute Rec;
    code : integer;
begin
  val(Data^, Result, code);
  if code<>0 then ReportError(flFormatError);
end;

procedure tRealFormatLine.SetData;
var Default : real absolute Rec;
begin
  if Default>1E6 then
    str(Default,Data^)
  else str(Default:0:8,Data^);
end;

function tRealFormatLine.DataSize : word;
begin
DataSize:=sizeof(Real);
end;

constructor tIntegerFormatLine.Init;
begin
tFormatLine.Init(Bounds,AMaxLen,'[+,-]#*#');
end;

procedure tIntegerFormatLine.SetData;
var Default : integer absolute Rec;
begin
str(Default,Data^);
end;

procedure tIntegerFormatLine.GetData;
var Result : integer absolute Rec;
    code : integer;
begin
val(Data^,Result,code);
if code<>0 then ReportError(flFormatError);
end;

function tIntegerFormatLine.DataSize : word;
begin
DataSize:=sizeof(integer);
end;

constructor tNameFormatLine.Init;
begin
tFormatLine.Init(Bounds,AMaxLen,'*[![*?][@][ ]]');
end;

constructor tZipFormatLine.Init;
begin
tFormatLine.Init(Bounds,AMaxLen,'#####[-####],&#& #&#');
end;

end.